

'-----------------------------------------------
' Hands-On 26-1
' No code in this Hands-On.
' Please follow the instructions in the book
'-----------------------------------------------


'-----------------------------------------------
' Hands-On 2
'-----------------------------------------------

Sub AccessToVBProj()
    Dim objVBProject As VBProject
    Dim strMsg1 As String
    Dim strMsg2 As String
    Dim response As Integer
    
    On Error Resume Next
    
    If Application.Version >= "12.0" Then
        Set objVBProject = ActiveWorkbook.VBProject

        strMsg2 = "The access to the VBA "
        strMsg2 = strMsg2 + " project must be trusted for this "
        strMsg2 = strMsg2 + "procedure to work."
        strMsg2 = strMsg2 + vbCrLf + vbCrLf
        strMsg2 = strMsg2 + " Click 'OK' to view instructions,"
        strMsg2 = strMsg2 + "  or click 'Cancel' to exit."
  
        If Err.Number <> 0 Then
            strMsg1 = "Please change the security settings to "
            strMsg1 = strMsg1 & "allow access to the VBA project:"
            strMsg1 = strMsg1 & Chr(10) & "1. "
            strMsg1 = strMsg1 & "Choose Developer | Macro Security."
            strMsg1 = strMsg1 & Chr(10) & "2. "
            strMsg1 = strMsg1 & "Check the 'Trust access to the VBA " _
                 & "project object model'. "
            strMsg1 = strMsg1 & Chr(10) & "3. Click OK."
        
            response = MsgBox(strMsg2, vbCritical + vbOKCancel, _
                        "Access to VB Project is not trusted")
                
                If response = 1 Then
                    Workbooks.Add
                    With ActiveSheet
                      .Shapes.AddTextbox(msoTextOrientationHorizontal, _
                         Left:=0, Top:=0, Width:=300, _
                         Height:=100).Select
                      Selection.Characters.Text = strMsg1
                      .Shapes(1).Fill.PresetTextured _
                       PresetTexture:=msoTextureBlueTissuePaper
                      .Shapes(1).Shadow.Type = msoShadow6
                    End With
                End If
            Exit Sub
        End If

        MsgBox "There are " & objVBProject.References.Count & _
            " project references in " & objVBProject.Name & "."
    End If
End Sub


'----------------------------------------
' Code to try out in the Immediate Window
'----------------------------------------

Workbooks("Practice_Excel26.xlsm").VBProject.Name = "Chap26SourceCode"
Workbooks("Practice_Excel26.xlsm").VBProject.Description = "Programming Visual Basic Editor"
MsgBox Application.VBE.ActiveVBProject.Saved
MsgBox Workbooks("Practice_Excel26.xlsm").VBProject.VBComponents.Count
Set objVBComp = Application.VBE.SelectedVBComponent
MsgBox objVBComp.Name


'----------------------------------------
' Hands-On 26-3
'----------------------------------------

Function IsProjProtected() As Boolean
    Dim objVBProj As VBProject

    Set objVBProj = ActiveWorkbook.VBProject

    If objVBProj.Protection = vbext_pp_locked Then
        IsProjProtected = True
    Else
        IsProjProtected = False
    End If
End Function


'----------------------------------------
' Hands-On 26-4
'----------------------------------------


Sub ModuleList()
    Dim objVBComp As VBComponent
    Dim listArray()
    Dim i As Integer

    If ThisWorkbook.VBProject.Protection = vbext_pp_locked Then
       MsgBox "You must unprotect the project to run this procedure."
       Exit Sub
    End If

    i = 2

    For Each objVBComp In ThisWorkbook.VBProject.VBComponents
        ReDim Preserve listArray(1 To 2, 1 To i - 1)
        listArray(1, i - 1) = objVBComp.Name
        listArray(2, i - 1) = GetModuleType(objVBComp)
        i = i + 1
    Next

    With ActiveSheet
        .Cells(1, 1).Resize(1, 2).Value = Array("Module Name", _
            "Module Type")
        .Cells(2, 1).Resize(UBound(listArray, 2), UBound(listArray, _
            1)).Value = Application.Transpose(listArray)
        .Columns("A:B").AutoFit
    End With

    Set objVBComp = Nothing
End Sub

Function GetModuleType(comp As VBComponent)
    Select Case comp.Type
        Case vbext_ct_StdModule
            GetModuleType = "Standard module"
        Case vbext_ct_ClassModule
            GetModuleType = "Class module"
        Case vbext_ct_MSForm
            GetModuleType = "Microsoft Form"
        Case vbext_ct_ActiveXDesigner
            GetModuleType = "ActiveX Designer"
        Case vbext_ct_Document
            GetModuleType = "Document module"
        Case Else
            GetModuleType = "Unknown"
    End Select
End Function

'----------------------------------------
' Hands-On 26-5
'----------------------------------------

Sub CreateModule()
    Dim modType As Integer
    Dim strName As String
    Dim strPrompt As String

    strPrompt = "Enter a number representing the type of module:"
    strPrompt = strPrompt & vbCr & "1 (Standard Module)"
    strPrompt = strPrompt & vbCr & "2 (Class Module)"

    modType = Val(InputBox(prompt:=strPrompt, Title:="Insert Module"))
    If modType = 0 Then Exit Sub
    strName = InputBox("Enter the name you want to assign to " & _
              "new module", "Module Name")
    If strName = "" Then Exit Sub
    AddModule modType, strName
End Sub


Sub AddModule(modType As Integer, strName As String)
    Dim objVBProj As VBProject
    Dim objVBComp As VBComponent

    If InStr(1, "1, 2", modType) = 0 Then Exit Sub

    Set objVBProj = ThisWorkbook.VBProject
    Set objVBComp = objVBProj.VBComponents.Add(modType)
    objVBComp.Name = strName

    Application.Visible = True

    Set objVBComp = Nothing
    Set objVBProj = Nothing
End Sub

'----------------------------------------
' Hands-On 26-6
'----------------------------------------

Sub DeleteModule(strName As String)
    Dim objVBProj As VBProject
    Dim objVBComp As VBComponent

    Set objVBProj = ThisWorkbook.VBProject

    Set objVBComp = objVBProj.VBComponents(strName)

    objVBProj.VBComponents.Remove objVBComp

    Set objVBComp = Nothing
    Set objVBProj = Nothing
End Sub

'----------------------------------------
' Hands-On 26-7
'----------------------------------------

Sub DeleteModuleCode(strName As String)
    Dim objVBProj As VBProject
    Dim objVBCode As CodeModule
    Dim firstLn As Long
    Dim totLn As Long

    Set objVBProj = ThisWorkbook.VBProject
    Set objVBCode = objVBProj.VBComponents(strName).CodeModule
    With objVBCode
        firstLn = 1
        totLn = .CountOfLines
        .DeleteLines firstLn, totLn
    End With

    Set objVBProj = Nothing
    Set objVBCode = Nothing
End Sub


'----------------------------------------
' Hands-On 26-8
'----------------------------------------

Sub DeleteEmptyModules()
    Dim objVBComp As VBComponent

    Const vbext_ct_StdModule As Long = 1
    Const vbext_ct_ClassModule As Long = 2

    For Each objVBComp In ActiveWorkbook.VBProject.VBComponents
      Select Case objVBComp.Type
        Case vbext_ct_StdModule, vbext_ct_ClassModule
          If objVBComp.CodeModule.CountOfLines < 3 Then
            Debug.Print "(deleted) " & objVBComp.Name & vbTab & _
            "declarations: " & objVBComp.CodeModule. _
            CountOfDeclarationLines & vbTab & "Total code Lines: " & _
            objVBComp.CodeModule.CountOfLines
            ActiveWorkbook.VBProject.VBComponents.Remove objVBComp
           End If
      End Select
    Next
    Set objVBComp = Nothing
End Sub


'----------------------------------------
' Hands-On 26-9
'----------------------------------------

Sub CopyAModule(wkbFrom As String, _
                wkbTo As String, _
                strFromMod As String)
    Dim wkb As Workbook
    Dim strFile As String

    Set wkb = Workbooks(wkbFrom)

    strFile = wkb.Path & "\vbCode.bas"
    wkb.VBProject.VBComponents(strFromMod).Export strFile

    On Error Resume Next
    Set wkb = Workbooks(wkbTo)
    If Err.Number <> 0 Then
        Workbooks.Open wkbTo
        Set wkb = Workbooks(wkbTo)
    End If

    wkb.VBProject.VBComponents.Import strFile
    wkb.Save

    Set wkb = Nothing
End Sub


'----------------------------------------
' Hands-On 26-10
'----------------------------------------

Sub CopyAllModules(wkbFrom As String, _
                   wkbTo As String)

    Dim objVBComp As VBComponent
    Dim wkb As Workbook
    Dim strFile As String

    Set wkb = Workbooks(wkbFrom)

    On Error Resume Next
    Workbooks(wkbTo).Activate
    If Err.Number <> 0 Then Workbooks.Open wkbTo

    strFile = wkb.Path & "\vbCode.bas"
    If Dir(strFile) <> "" Then Kill strFile

    For Each objVBComp In wkb.VBProject.VBComponents
        If objVBComp.Type <> vbext_ct_Document Then
            objVBComp.Export strFile
            Workbooks(wkbTo).VBProject.VBComponents.Import strFile
        End If
    Next

    Set objVBComp = Nothing
    Set wkb = Nothing
End Sub


Sub CopyAllModulesRevised(wkbFrom As String, _
                    wkbTo As String)

    Dim objVBComp As VBComponent
    Dim wkb As Workbook
    Dim strFile As String

    Set wkb = Workbooks(wkbFrom)

    On Error Resume Next
    Workbooks(wkbTo).Activate
    If Err.Number <> 0 Then Workbooks.Open wkbTo

    strFile = wkb.Path & "\vbCode.bas"
    If Dir(strFile) <> "" Then Kill strFile

    For Each objVBComp In wkb.VBProject.VBComponents
        If objVBComp.Type <> vbext_ct_Document Then
            objVBComp.Export strFile

          With Workbooks(wkbTo)
            If Len(.VBProject.VBComponents(objVBComp.Name).Name) = 0 Then
              Workbooks(wkbTo).VBProject.VBComponents.Import strFile
            End If
          End With
        End If
    Next

    Set objVBComp = Nothing
    Set wkb = Nothing
End Sub


'----------------------------------------
' Hands-On 26-11
'----------------------------------------

Sub ListAllProc()
    Dim objVBProj As VBProject
    Dim objVBComp As VBComponent
    Dim objVBCode As CodeModule
    Dim strCurrent As String
    Dim strPrevious As String

    Dim x As Integer

    Set objVBProj = ThisWorkbook.VBProject

    For Each objVBComp In objVBProj.VBComponents
    If InStr(1, "1, 2", objVBComp.Type) Then
        Set objVBCode = objVBComp.CodeModule
        Debug.Print objVBComp.Name

        For x = objVBCode.CountOfDeclarationLines + 1 To _
                objVBCode.CountOfLines
           strCurrent = objVBCode.ProcOfLine(x, vbext_pk_Proc)

           If strCurrent <> strPrevious Then
              Debug.Print vbTab & objVBCode.ProcOfLine(x, vbext_pk_Proc)
              strPrevious = strCurrent
           End If
        Next
    End If
    Next

    Set objVBCode = Nothing

    Set objVBComp = Nothing
    Set objVBProj = Nothing
End Sub



'----------------------------------------
' Hands-On 26-12
'----------------------------------------

Sub AddNewProc(strModName As String)
    Dim objVBCode As CodeModule
    Dim objVBProj As VBProject
    Dim strProc As String

    Set objVBProj = ThisWorkbook.VBProject

    Set objVBCode = objVBProj.VBComponents(strModName).CodeModule

    strProc = "Sub CreateWorkBook()" & Chr(13)
    strProc = strProc & Chr(9) & "Workbooks.Add" & Chr(13)
    strProc = strProc & Chr(9) & "ActiveSheet.Name = ""Test"" " & Chr(13)
    strProc = strProc & "End Sub"

    Debug.Print strProc

    With objVBCode
        .InsertLines .CountOfLines + 1, strProc
    End With

    Set objVBCode = Nothing
    Set objVBProj = Nothing
End Sub


'----------------------------------------
' Hands-On 26-13
'----------------------------------------

Sub DeleteProc(strModName As String, strProcName As String)
    Dim objVBProj As VBProject
    Dim objVBCode As CodeModule
    Dim firstLn As Long
    Dim totLn As Long

    Set objVBProj = ThisWorkbook.VBProject
    Set objVBCode = objVBProj.VBComponents(strModName).CodeModule
    With objVBCode
      firstLn = .ProcStartLine(strProcName, vbext_pk_Proc)
      totLn = .ProcCountLines(strProcName, vbext_pk_Proc)
     .DeleteLines firstLn, totLn
    End With

    Set objVBProj = Nothing
    Set objVBCode = Nothing
End Sub


Function ModuleExists(strModName As String) As Boolean
    Dim objVBProj As VBProject

    Set objVBProj = ThisWorkbook.VBProject

    On Error Resume Next

    ModuleExists = Len(objVBProj.VBComponents(strModName).Name) <> 0
End Function


Function ProcExists(strModName As String, _
                    strProcName As String) As Boolean

    Dim objVBProj As VBProject

    Set objVBProj = ThisWorkbook.VBProject

    On Error Resume Next

    ' first find out if the specified module exists
    If ModuleExists(strModName) = True Then
        ProcExists = objVBProj.VBComponents(strModName) _
            .CodeModule.ProcStartLine(strProcName, vbext_pk_Proc) <> 0
    End If
End Function


'----------------------------------------
' Hands-On 26-14
'----------------------------------------

Sub CreateWorkSelChangeEvent()
    Dim objVBCode As CodeModule
    Dim wks As Worksheet
    Dim firstLine As Long

   ' Add a new worksheet
   Set wks = ActiveWorkbook.Worksheets.Add

   ' create a reference to the code module of the inserted sheet
   Set objVBCode = wks.Parent.VBProject.VBComponents(wks.Name).CodeModule

   ' create an event procedure and return the line at which the body of
   ' the event procedure begins
   firstLine = objVBCode.CreateEventProc("SelectionChange", "Worksheet")

   Debug.Print "Procedure first line: " & firstLine

   ' proceed to add code to the body of the event procedure
   objVBCode.InsertLines firstLine + 1, _
       Chr(9) & "Dim myRange As Range"
    objVBCode.InsertLines firstLine + 2, _
       Chr(9) & "On Error Resume Next"
   objVBCode.InsertLines firstLine + 3, _
       Chr(9) & "Set myRange = Intersect(Range(""A1:A10""), Target)"
   objVBCode.InsertLines firstLine + 4, _
       Chr(9) & "If Not myRange Is Nothing Then"
   objVBCode.InsertLines firstLine + 5, _
        Chr(9) & Chr(9) & _
        "MsgBox ""Data entry or edits are not permitted."""
   objVBCode.InsertLines firstLine + 6, _
       Chr(9) & "End If"

  Set objVBCode = Nothing
  Set wks = Nothing
End Sub


'----------------------------------------
' Code in the section "Working with UserForms"
'----------------------------------------

Sub ReportGeneratorForm()
    Dim objVBComp As VBComponent
    
    Set objVBComp = Application.VBE.ActiveVBProject. _
        VBComponents.Add(vbext_ct_MSForm)
    With objVBComp
        .Name = "ReportGenerator"
        .Properties("Caption") = "My Report Form"
    End With
    Set objVBComp = Nothing
End Sub

' execute from the Immediate Window
Set objVBComp = Application.VBE.ActiveVBProject.VBComponents("ReportGenerator")
Application.VBE.ActiveVBProject.VBComponents.Remove objVBComp


'----------------------------------------
' Hands-On 26-15
'----------------------------------------

Sub AddUserForm()
    Dim objVBProj As VBProject
    Dim objVBComp As VBComponent
    Dim objVBFrm As UserForm
    Dim objChkBox As Object
    Dim x As Integer
    Dim sVBA As String
     
    Set objVBProj = Application.VBE.ActiveVBProject
    Set objVBComp = objVBProj.VBComponents.Add(vbext_ct_MSForm)
    
    With objVBComp
    ' read form's name and other properties
        Debug.Print "Default Name " & .Name
        Debug.Print "Caption: " & .DesignerWindow.Caption
        Debug.Print "Form is open in the Designer window: " & .HasOpenDesigner
        Debug.Print "Form Name " & .Name
        Debug.Print "Default Width " & .Properties("Width")
        Debug.Print "Default Height " & .Properties("Height")

    ' ret form's name, caption and size
        .Name = "ReportSelector"
        .Properties("Width") = 250
        .Properties("Height") = 250
        .Properties("Caption") = "Request Report"
    End With
      
      Set objVBFrm = objVBComp.Designer
      With objVBFrm
           With .Controls.Add("Forms.Label.1", "lbName")
                .Caption = "Department:"
                .AutoSize = True
                .Width = 48
                .Top = 30
                .Left = 20
            End With
        
            With .Controls.Add("Forms.Combobox.1", "cboDept")
                .Width = 110
                .Top = 30
                .Left = 70
            End With
    
            ' add frame control
            With .Controls.Add("Forms.Frame.1", "frReports")
                .Caption = "Choose Report Type"
                .Top = 60
                .Left = 18
                .Height = 96
            End With
            
            ' add three check boxes
            Set objChkBox = .frReports.Controls.Add("Forms.CheckBox.1")
            With objChkBox
                 .Name = "chk1"
                 .Caption = "Last Month's Performance Report"
                 .WordWrap = False
                 .Left = 12
                 .Top = 12
                 .Height = 20
                 .Width = 186
            End With
            
            Set objChkBox = .frReports.Controls.Add("Forms.CheckBox.1")
            With objChkBox
                 .Name = "chk2"
                 .Caption = "Last Qtr. Performance Report"
                 .WordWrap = False
                 .Left = 12
                 .Top = 32
                 .Height = 20
                 .Width = 186
            End With
            
            Set objChkBox = .frReports.Controls.Add("Forms.CheckBox.1")
            With objChkBox
                 .Name = "chk3"
                 .Caption = Year(Now) - 1 & " Performance Report"
                 .WordWrap = False
                 .Left = 12
                 .Top = 54
                 .Height = 20
                 .Width = 186
            End With

            ' Add and position OK and Cancel buttons
              With .Controls.Add("Forms.CommandButton.1", "cmdOK")
                  .Caption = "OK"
                  .Default = "True"
                  .Height = 20
                  .Width = 60
                  .Top = objVBFrm.InsideHeight - .Height - 20
                  .Left = objVBFrm.InsideWidth - .Width - 10
              End With
            
                With .Controls.Add("Forms.CommandButton.1", "cmdCancel")
                    .Caption = "Cancel"
                    .Height = 20
                    .Width = 60
                    .Top = objVBFrm.InsideHeight - .Height - 20
                    .Left = objVBFrm.InsideWidth - .Width - 80
                End With
    End With
    
     'populate the combo box
     With objVBComp.CodeModule
        x = .CountOfLines
        .InsertLines x + 1, "Sub UserForm_Initialize()"
        .InsertLines x + 2, vbTab & "With Me.cboDept"
        .InsertLines x + 3, vbTab & vbTab & ".addItem ""Marketing"""
        .InsertLines x + 4, vbTab & vbTab & ".addItem ""Sales"""
        .InsertLines x + 5, vbTab & vbTab & ".addItem ""Finance"""
        .InsertLines x + 6, vbTab & vbTab & ".addItem ""Research & Development"""
        .InsertLines x + 7, vbTab & vbTab & ".addItem ""Human Resources"""

        .InsertLines x + 8, vbTab & "End With"
        .InsertLines x + 9, "End Sub"
            
        ' write a procedure to handle the Cancel button
            
        Dim firstLine As Long
        With objVBComp.CodeModule
             firstLine = .CreateEventProc("Click", "cmdCancel")
            .InsertLines firstLine + 1, "    Unload Me"
        End With
        
        ' write a procedure to handle OK button
        sVBA = "Private Sub cmdOK_Click()" & vbCrLf
        sVBA = sVBA & "    Dim ctrl As Control" & vbCrLf
        sVBA = sVBA & "    Dim chkflag As Integer" & vbCrLf
        sVBA = sVBA & "    Dim strMsg As String" & vbCrLf
        sVBA = sVBA & "    If Me.cboDept.Value = """" Then " & vbCrLf
        sVBA = sVBA & "       MsgBox ""Please select the Department.""" & vbCrLf
        sVBA = sVBA & "       Me.cboDept.SetFocus " & vbCrLf
        sVBA = sVBA & "       Exit Sub" & vbCrLf
        sVBA = sVBA & "    End If" & vbCrLf
        sVBA = sVBA & "    For Each ctrl In Me.Controls " & vbCrLf
        sVBA = sVBA & "       Select Case ctrl.Name" & vbCrLf
        sVBA = sVBA & "         Case ""chk1"", ""chk2"", ""chk3""" & vbCrLf
        sVBA = sVBA & "           If ctrl.Value = True Then" & vbCrLf
        sVBA = sVBA & "             strMsg = strMsg & ctrl.Caption & Chr(13)" & vbCrLf
        sVBA = sVBA & "             chkflag = 1" & vbCrLf
        sVBA = sVBA & "           End If" & vbCrLf
        sVBA = sVBA & "       End Select" & vbCrLf
        sVBA = sVBA & "    Next" & vbCrLf
        sVBA = sVBA & "    If chkflag = 1 Then" & vbCrLf
        sVBA = sVBA & "      MsgBox ""Run the following Report(s) for "" & _ " & vbCrLf
        sVBA = sVBA & "      Me.cboDept.Value & "":"" & Chr(13) & Chr(13) & strMsg" & vbCrLf
        sVBA = sVBA & "    Else" & vbCrLf
        sVBA = sVBA & "      MsgBox ""Please select Report type.""" & vbCrLf
        sVBA = sVBA & "    End If" & vbCrLf
        sVBA = sVBA & "End Sub"

        .AddFromString sVBA
  
    End With
End Sub


'----------------------------------------
' Hands-On 26-16
'----------------------------------------

Sub UserFormCopy(strFileName As String)
    Dim objVBComp As VBComponent
    Dim wkb As Workbook


    On Error Resume Next
        Set wkb = Workbooks(strFileName)
        If Err.Number <> 0 Then
            Workbooks.Open ActiveWorkbook.Path & "\" & strFileName
            Set wkb = Workbooks(strFileName)
        End If

    For Each objVBComp In ThisWorkbook.VBProject.VBComponents
        If objVBComp.Type = 3 Then  ' this is a UserForm
            ' export the UserForm to disk
            objVBComp.Export Filename:=objVBComp.Name
            ' import the UserForm to specific workbook
            wkb.VBProject.VBComponents.Import Filename:=objVBComp.Name
            ' delete two form files created by the Export method
            Kill objVBComp.Name
            Kill objVBComp.Name & ".frx"
        End If
    Next

    ' add a standard module to the workbook
    ' and write code to show the UserForm
    Set objVBComp = wkb.VBProject.VBComponents.Add(vbext_ct_StdModule)

    objVBComp.CodeModule.AddFromString _
        "Sub ShowReportSelector()" & vbCrLf & _
        "    ReportSelector.Show" & vbCrLf & _
        "End Sub" & vbCrLf

    ' close the Code pane
    objVBComp.CodeModule.CodePane.Window.Close

    ' run the ShowReportSelector procedure to display the form
    Application.Run wkb.Name & "!ShowReportSelector"

    Set objVBComp = Nothing
    Set wkb = Nothing
End Sub


'----------------------------------------
' Hands-On 26-17
'----------------------------------------

Sub ListPrjCompRef()
  Dim objVBPrj As VBIDE.VBProject
  Dim objVBCom As VBIDE.VBComponent
  Dim vbRef As VBIDE.Reference

    ' List VBAProjects as well as references and
    ' component names they contain
    For Each objVBPrj In Application.VBE.VBProjects
        Debug.Print objVBPrj.Name
        Debug.Print vbTab & "References"
        For Each vbRef In objVBPrj.References
            With vbRef
               Debug.Print vbTab & vbTab & .Name & "---" & .FullPath
            End With
        Next
        Debug.Print vbTab & "Components"
        For Each objVBCom In objVBPrj.VBComponents
            Debug.Print vbTab & vbTab & objVBCom.Name
        Next
    Next
    Set vbRef = Nothing
    Set objVBCom = Nothing
    Set objVBPrj = Nothing
End Sub


'----------------------------------------
' Hands-On 26-18
'----------------------------------------

Sub AddRef()
    Dim objVBProj As VBProject

    Set objVBProj = ThisWorkbook.VBProject

    On Error GoTo ErrorHandle
    objVBProj.References.AddFromFile "C:\Windows\System32\scrrun.dll"
    MsgBox "The reference to the Microsoft Scripting Runtime was set."
    Application.SendKeys "%tr"

ExitHere:
    Set objVBProj = Nothing
    Exit Sub
ErrorHandle:
    MsgBox "The reference to the Microsoft Scripting Runtime" & _
        " already exists."
    GoTo ExitHere
End Sub


'----------------------------------------
' Hands-On 26-19
'----------------------------------------

Sub AddRef_FromGuid()
    Dim objVBProj As VBProject
    Dim i As Integer
    Dim strName As String
    Dim strGuid As String
    Dim strMajor As Long
    Dim strMinor As Long

    Set objVBProj = ActiveWorkbook.VBProject

    ' Find out what libraries are already installed
    For i = 1 To objVBProj.References.Count
          strName = objVBProj.References(i).Name
          strGuid = objVBProj.References(i).GUID
          strMajor = objVBProj.References(i).Major
          strMinor = objVBProj.References(i).Minor
          Debug.Print strName & " - " & strGuid & _
            ", " & strMajor & ", " & strMinor
    Next i

    ' add a reference to the Microsoft DAO 3.6 Object Library
    On Error Resume Next
    ThisWorkbook.VBProject.References.AddFromGuid _
       "{00025E01-0000-0000-C000-000000000046}", 5, 0
End Sub


'----------------------------------------
' Hands-On 26-20
'----------------------------------------

Sub RemoveRef()
    Dim objVBProj As VBProject
    Dim objRef As Reference
    Dim sRefFile As String

    Set objVBProj = ActiveWorkbook.VBProject

    ' Loop through the references and delete the reference to DAO Library
    For Each objRef In objVBProj.References
        If InStr(1, objRef.Description, "DAO 3.6") > 0 Then
            objVBProj.References.Remove objRef
            Exit For
        End If
    Next objRef
End Sub


'----------------------------------------
' Hands-On 26-21 -- code in ThisWorkbook Code Module
'----------------------------------------

Private Sub Workbook_Open()
   Dim objVBProj As VBProject
   Dim objRef As Reference
   Dim refBroken As Boolean

   Set objVBProj = ThisWorkbook.VBProject

   ' Loop through the selected references in
   ' the References dialog box
   For Each objRef In objVBProj.References
   ' If the reference is broken, get its name and its GUID
      If objRef.IsBroken Then
         Debug.Print objRef.Name
         Debug.Print objRef.GUID
         refBroken = True
      End If
   Next
   If refBroken = False Then
        Debug.Print "All references are valid."
   End If
End Sub


'----------------------------------------
' Hands-On 26-22
'----------------------------------------

Sub Close_ImmediateWin()
    Dim objWin As VBIDE.Window
    Dim strOpenWindows As String

    strOpenWindows = "The following windows are open:" & _
           vbCrLf & vbCrLf

    For Each objWin In Application.VBE.Windows
        Select Case objWin.Type
            Case vbext_wt_Immediate
                MsgBox objWin.Caption & " window  was closed."
                objWin.Close
            Case Else
                strOpenWindows = strOpenWindows & _
                    objWin.Caption & vbCrLf
        End Select
    Next
    MsgBox strOpenWindows
    Set objWin = Nothing
End Sub


'----------------------------------------
' Hands-On 26-23
'----------------------------------------

Sub ListVBECmdBars()
    Dim objCmdBar As CommandBar
    Dim strCmdType As String
    Dim c As Variant

    Workbooks.Add
    Range("A1").Select

    With ActiveCell
        .Offset(0, 0) = "CommandBar Name"
        .Offset(0, 1) = "Control Caption"
        .Offset(0, 2) = "Control ID"
    End With

    For Each objCmdBar In Application.VBE.CommandBars
        Select Case objCmdBar.Type
            Case 0
                strCmdType = "toolbar"
            Case 1
                strCmdType = "menu bar"
            Case 2
                strCmdType = "popup menu"
        End Select

        ActiveCell.Offset(1, 0) = objCmdBar.Name & _
                    " (" & strCmdType & ")"

        For Each c In objCmdBar.Controls
            ActiveCell.Offset(1, 0).Select
            With ActiveCell
                .Offset(0, 1) = c.Caption
                .Offset(0, 2) = c.ID
            End With
        Next
    Next

    Columns("A:C").AutoFit

    Set objCmdBar = Nothing
End Sub


'----------------------------------------
' Hands-On 26-24
'----------------------------------------

' module-level declaration
Dim myClickEvent As clsCmdBarEvents

Sub AddCmdButton_ToVBE()
    Dim objCmdBar As CommandBar
    Dim objCmdBtn As CommandBarButton

   ' get the reference to the Tools menu in the VBE
    Set objCmdBar = Application.VBE.CommandBars.FindControl _
         (ID:=30007).CommandBar

    ' add a button to the Tools menu
    Set objCmdBtn = objCmdBar.Controls.Add(msoControlButton)

    ' set the new button's properties
    With objCmdBtn
        .Caption = "List VBE menus and toolbars"
        .OnAction = "ListVBECmdBars"
     End With

    ' create an instance of the clsCmdEvents class
    Set myClickEvent = New clsCmdBarEvents

    ' hook up the class instance to the newly added button
    Set myClickEvent.cmdBtnEvents = objCmdBtn

    Set objCmdBtn = Nothing
    Set objCmdBar = Nothing

End Sub


' class module declaration line
Public WithEvents cmdBtnEvents As CommandBarButton

' class module procedure
Private Sub cmdBtnEvents_Click(ByVal Ctrl As Office.CommandBarButton, _
                CancelDefault As Boolean)
    On Error Resume Next

    ' run the procedure specified in the onAction property
    Application.Run Ctrl.OnAction

    ' specify that we already handled this event
    CancelDefault = True
End Sub


'----------------------------------------
' Hands-On 26-25
'----------------------------------------

Sub RemoveCmdButton_FromVBE()
    Dim objCmdBar As CommandBar
    Dim objCmdBarCtrl As CommandBarControl

    ' get the reference to the Tools menu in the VBE
    Set objCmdBar = Application.VBE.CommandBars("Tools")

    ' loop through the Tools menu controls
    ' and delete the control with the matching caption
    For Each objCmdBarCtrl In objCmdBar.Controls
        If objCmdBarCtrl.Caption = "List VBE menus and toolbars" Then
            objCmdBarCtrl.Delete
        End If
    Next

    Set objCmdBarCtrl = Nothing
    Set objCmdBar = Nothing
End Sub


